// $Id: HTTPGet.pas 6 2012-06-24 15:31:11Z zerogle $
{*************************************************************}
{            HTTPGet component for Delphi 32                  }
{ Version:   1.94                                             }
{ E-Mail:    info@utilmind.com                                }
{ WWW:       http://www.utilmind.com                          }
{ Created:   October  19, 1999                                }
{ Modified:  June 6, 2000                                     }
{ Legal:     Copyright (c) 1999-2000, UtilMind Solutions      }
{*************************************************************}
{ PROPERTIES:                                                 }
{   Agent: String - User Agent                                }
{                                                             }
{*  BinaryData: Boolean - This setting specifies which type   }
{*                        of data will taken from the web.    }
{*                        If you set this property TRUE then  }
{*                        component will determinee the size  }
{*                        of files *before* getting them from }
{*                        the web.                            }
{*                        If this property is FALSE then as we}
{*                        do not knows the file size the      }
{*                        OnProgress event will doesn't work. }
{*                        Also please remember that is you set}
{*                        this property as TRUE you will not  }
{*                        capable to get from the web ASCII   }
{*                        data and ofter got OnError event.   }
{                                                             }
{   FileName: String - Path to local file to store the data   }
{                      taken from the web                     }
{   Password, UserName - set this properties if you trying to }
{                        get data from password protected     }
{                        directories.                         }
{   Referer: String - Additional data about referer document  }
{   URL: String - The url to file or document                 }
{   UseCache: Boolean - Get file from the Internet Explorer's }
{                       cache if requested file is cached.    }
{*************************************************************}
{ METHODS:                                                    }
{   GetFile - Get the file from the web specified in the URL  }
{             property and store it to the file specified in  }
{             the FileName property                           }
{   GetString - Get the data from web and return it as usual  }
{               String. You can receive this string hooking   }
{               the OnDoneString event.                       }
{   Abort - Stop the current session                          }
{*************************************************************}
{ EVENTS:                                                     }
{   OnDoneFile - Occurs when the file is downloaded           }
{   OnDoneString - Occurs when the string is received         }
{   OnError - Occurs when error happend                       }
{   OnProgress - Occurs at the receiving of the BINARY DATA   }
{*************************************************************}
{ Please see demo program for more information.               }
{*************************************************************}
{                     IMPORTANT NOTE:                         }
{ This software is provided 'as-is', without any express or   }
{ implied warranty. In no event will the author be held       }
{ liable for any damages arising from the use of this         }
{ software.                                                   }
{ Permission is granted to anyone to use this software for    }
{ any purpose, including commercial applications, and to      }
{ alter it and redistribute it freely, subject to the         }
{ following restrictions:                                     }
{ 1. The origin of this software must not be misrepresented,  }
{    you must not claim that you wrote the original software. }
{    If you use this software in a product, an acknowledgment }
{    in the product documentation would be appreciated but is }
{    not required.                                            }
{ 2. Altered source versions must be plainly marked as such,  }
{    and must not be misrepresented as being the original     }
{    software.                                                }
{ 3. This notice may not be removed or altered from any       }
{    source distribution.                                     }
{*************************************************************}

unit HTTPGet;

interface

uses
  Windows, Messages, SysUtils, Classes, WinInet;

type
  TOnProgressEvent = procedure(Sender: TObject; TotalSize,
    Readed: Integer) of object;

  TOnDoneFileEvent = procedure(Sender: TObject; FileName: String;
    FileSize: Integer) of object;

  TOnDoneStringEvent = procedure(Sender: TObject; Result: String) of object;

  THTTPGetThread = class(TThread)
  private
    FTAcceptTypes: String;
    FTAgent: String;
    FTURL: String;
    FTFileName: String;
    FTStringResult: String;
    FTUserName: String;
    FTPassword: String;
    FTPostQuery: String;
    FTReferer: String;
    FTBinaryData: Boolean;
    FTUseCache: Boolean;
    FTResult: Boolean;
    FTFileSize: Integer;
    FTToFile: Boolean;
    BytesToRead, BytesReaded: DWORD;
    FTProgress: TOnProgressEvent;
    procedure UpdateProgress;
  protected
    procedure Execute; override;
  public
    constructor Create(AAcceptTypes, AAgent, AURL, AFileName, AUserName,
      APassword, APostQuery, AReferer: String; ABinaryData, AUseCache: Boolean;
      AProgress: TOnProgressEvent; AToFile: Boolean);
  end;

  THTTPGet = class(TComponent)
  private
    FAcceptTypes: String;
    FAgent: String;
    FBinaryData: Boolean;
    FURL: String;
    FUseCache: Boolean;
    FFileName: String;
    FUserName: String;
    FPassword: String;
    FPostQuery: String;
    FReferer: String;
    FWaitThread: Boolean;
    FThread: THTTPGetThread;
    FError: TNotifyEvent;
    FResult: Boolean;
    FProgress: TOnProgressEvent;
    FDoneFile: TOnDoneFileEvent;
    FDoneString: TOnDoneStringEvent;
    procedure ThreadDone(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure GetFile;
    procedure GetString;
    procedure Abort;
  published
    property AcceptTypes: String read FAcceptTypes write FAcceptTypes;
    property Agent: String read FAgent write FAgent;
    property BinaryData: Boolean read FBinaryData write FBinaryData;
    property URL: String read FURL write FURL;
    property UseCache: Boolean read FUseCache write FUseCache;
    property FileName: String read FFileName write FFileName;
    property UserName: String read FUserName write FUserName;
    property Password: String read FPassword write FPassword;
    property PostQuery: String read FPostQuery write FPostQuery;
    property Referer: String read FReferer write FReferer;
    property WaitThread: Boolean read FWaitThread write FWaitThread;
    property OnProgress: TOnProgressEvent read FProgress write FProgress;
    property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;
    property OnDoneString: TOnDoneStringEvent read FDoneString write FDoneString;
    property OnError: TNotifyEvent read FError write FError;
  end;

  procedure Register;

implementation

{ THTTPGetThread }

constructor THTTPGetThread.Create(AAcceptTypes, AAgent, AURL, AFileName,
  AUserName, APassword, APostQuery, AReferer: String; ABinaryData,
  AUseCache: Boolean; AProgress: TOnProgressEvent; AToFile: Boolean);
begin
  FreeOnTerminate := True;

  inherited Create(True);

  FTAcceptTypes := AAcceptTypes;
  FTAgent := AAgent;
  FTURL := AURL;
  FTFileName := AFileName;
  FTUserName := AUserName;
  FTPassword := APassword;
  FTPostQuery := APostQuery;
  FTReferer := AReferer;
  FTProgress := AProgress;
  FTBinaryData := ABinaryData;
  FTUseCache := AUseCache;
  FTToFile := AToFile;

  Resume;
end;

procedure THTTPGetThread.UpdateProgress;
begin
  FTProgress(Self, FTFileSize, BytesReaded);
end;

procedure THTTPGetThread.Execute;
var
  hSession, hConnect, hRequest: HINTERNET;
  HostName, FileName: String;
  F: File;
  Buf: Pointer;
  dwBufLen, dwIndex: DWORD;
  Data: array[0..$400] of Char;
  TempStr: String;
  RequestMethod: PChar;
  InternetFlag: DWORD;
  AcceptType: LPStr;

  {procedure ReplaceChar(C1, C2: Char; var St: String);
  var
    P: Integer;
  begin
    while True do
    begin
      P := Pos(C1, St);
      if (P = 0) then
        Break
      else
        St[P] := C2;
    end;
  end;}

  procedure ParseURL(URL: String; var HostName, FileName: String);
  var
    I: Integer;
  begin
    if (Pos('http://', LowerCase(URL)) = 1) then
      System.Delete(URL, 1, 7);
    I := Pos('/', URL);
    HostName := Copy(URL, 1, I);
    FileName := Copy(URL, I, Length(URL) - I + 1);
    if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then
      SetLength(HostName, Length(HostName) - 1);
  end;

  procedure CloseHandles;
  begin
    InternetCloseHandle(hRequest);
    InternetCloseHandle(hConnect);
    InternetCloseHandle(hSession);
  end;

begin
  try
    ParseURL(FTURL, HostName, FileName);

    if Terminated then
    begin
      FTResult := False;
      Exit;
    end;

    if (FTAgent <> '') then
      hSession := InternetOpen(PChar(FTAgent), INTERNET_OPEN_TYPE_DIRECT,
        nil, nil, 0)
    else
      hSession := InternetOpen(nil, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);

    hConnect := InternetConnect(hSession, PChar(HostName),
      INTERNET_DEFAULT_HTTP_PORT, PChar(FTUserName), PChar(FTPassword),
      INTERNET_SERVICE_HTTP, 0, 0);

    if (FTPostQuery = '') then
      RequestMethod := 'GET'
    else
      RequestMethod := 'POST';

    if FTUseCache then
      InternetFlag := 0
    else
      InternetFlag := INTERNET_FLAG_RELOAD;

    AcceptType := PChar('Accept: ' + FTAcceptTypes);
    hRequest := HttpOpenRequest(hConnect, RequestMethod, PChar(FileName),
      'HTTP/1.1', PChar(FTReferer), @AcceptType, InternetFlag, 0);

    if (FTPostQuery = '') then
      HttpSendRequest(hRequest, nil, 0, nil, 0)
    else
      HttpSendRequest(hRequest,
        'Content-Type: application/x-www-form-urlencoded', 47,
        PChar(FTPostQuery), Length(FTPostQuery));

    if Terminated then
    begin
      CloseHandles;
      FTResult := False;
      Exit;
    end;

    dwIndex  := 0;
    dwBufLen := 1024;
    GetMem(Buf, dwBufLen);

    FTResult := HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH, Buf,
      dwBufLen, dwIndex);

    if Terminated then
    begin
      FreeMem(Buf);
      CloseHandles;
      FTResult := False;
      Exit;
    end;

    if FTResult or not FTBinaryData then
    begin
      if FTResult then
        FTFileSize := StrToInt(StrPas(Buf));

      BytesReaded := 0;

      if FTToFile then
      begin
        AssignFile(F, FTFileName);
        Rewrite(F, 1);
      end
      else
        FTStringResult := '';

      while True do
      begin
        if Terminated then
        begin
          if FTToFile then
            CloseFile(F);
          FreeMem(Buf);
          CloseHandles;

          FTResult := False;
          Exit;
        end;

        if not InternetReadFile(hRequest, @Data, SizeOf(Data), BytesToRead) then
          Break
        else
        if (BytesToRead = 0) then
          Break
        else
        begin
          if FTToFile then
            BlockWrite(F, Data, BytesToRead)
          else
          begin
            TempStr := Data;
            SetLength(TempStr, BytesToRead);
            FTStringResult := FTStringResult + TempStr;
          end;

          Inc(BytesReaded, BytesToRead);
          if Assigned(FTProgress) then
            Synchronize(UpdateProgress);
        end;
      end;

      if FTToFile then
        FTResult := (FTFileSize = Integer(BytesReaded))
      else
      begin
        SetLength(FTStringResult, BytesReaded);
        FTResult := (BytesReaded <> 0);
      end;

      if FTToFile then CloseFile(F);
    end;

    FreeMem(Buf);

    CloseHandles;
  except
  end;
end;

{ HTTPGet }

constructor THTTPGet.Create(AOwner: TComponent);
begin
  inherited Create(aOwner);
  FAcceptTypes := '*/*';
  FAgent := 'UtilMind HTTPGet';
end;

destructor THTTPGet.Destroy;
begin
  Abort;
  inherited Destroy;
end;

procedure THTTPGet.GetFile;
var
  Msg: TMsg;
begin
  if not Assigned(FThread) then
  begin
    FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName,
      FUserName, FPassword, FPostQuery, FReferer, FBinaryData, FUseCache,
      FProgress, True);
    FThread.OnTerminate := ThreadDone;
    if FWaitThread then
    begin
      while Assigned(FThread) do
      begin
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;
      end;
    end;
  end;
end;

procedure THTTPGet.GetString;
var
  Msg: TMsg;
begin
  if not Assigned(FThread) then
  begin
    FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName,
      FUserName, FPassword, FPostQuery, FReferer, FBinaryData, FUseCache,
      FProgress, False);
    FThread.OnTerminate := ThreadDone;
    if FWaitThread then
    begin
      while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
    end;
  end;
end;

procedure THTTPGet.Abort;
begin
  if Assigned(FThread) then
  begin
    FThread.Terminate;
    FThread.FTResult := False;
  end;
end;

procedure THTTPGet.ThreadDone(Sender: TObject);
begin
  if not FThread.Terminated then
  begin
    FResult := FThread.FTResult;
    if FResult then
    begin
      if FThread.FTToFile then
      begin
        if Assigned(FDoneFile) then
          FDoneFile(Self, FThread.FTFileName, FThread.FTFileSize);
      end
      else
      begin
        if Assigned(FDoneString) then
          FDoneString(Self, FThread.FTStringResult);
      end;
    end
    else
    begin
      if Assigned(FError) then
        FError(Self);
    end;
  end;
  FThread := nil;
end;

procedure Register;
begin
  //RegisterComponents('UtilMind', [THTTPGet]);
  RegisterComponents('pLan Components', [THTTPGet]);
end;

end.
